;; resolve.scm: Validation and type resolution routines for r6rs-thrift
;; Copyright (C) 2012 Julian Graham

;; r6rs-thrift is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

#!r6rs

(library (thrift compile resolve)
  (export thriftc:resolve)
  (import (rnrs)
	  (srfi :13)
	  (thrift compile conditions)
	  (thrift compile parse)
	  (thrift compile tokenize)
	  (thrift compile type)
	  (thrift private))

  (define container-prototypes
    (let ((ht (make-hashtable string-hash equal?)))
      (for-each 
       (lambda (descriptor)
	 (hashtable-set!
	  ht (thrift:field-type-descriptor-name descriptor) descriptor))
       (list thrift:field-type-list-prototype
	     thrift:field-type-map-prototype
	     thrift:field-type-set-prototype))
      ht))
  
  (define-record-type (thriftc:type-resolution-context-registry
		       thriftc:make-type-resolution-context-registry
		       thriftc:type-resolution-context-registry?)
    (fields root external-contexts)
    (protocol (lambda (p)
		(lambda (root)
		  (p root (make-hashtable string-hash equal?))))))

  (define-record-type (thriftc:type-resolution-context
		       thriftc:make-type-resolution-context
		       thriftc:type-resolution-context?)
    (fields prefix
	    namespace
	    declared-types
	    unresolved-references)
    (protocol (lambda (p)
		(lambda (prefix namespace)
		  (p prefix namespace
		     (make-hashtable string-hash equal?) 
		     (make-hashtable string-hash equal?))))))

  (define (resolve-type-reference reference registry)
    (define name (thrift:type-reference-name reference))

    (define (resolve-complex-type-reference reference)
      (or (hashtable-contains? container-prototypes name)
	  (raise (condition
		  (make-assertion-violation)
		  (make-message-condition 
		   (string-append "Unknown complex type " name))
		  (thriftc:make-type-resolution-condition))))
      
      (let ((parameters (thrift:complex-type-reference-parameters reference))
	    (prototype (hashtable-ref container-prototypes name #f)))
	(for-each (lambda (parameter) 
		    (resolve-type-reference parameter registry))
		  parameters)
	(thrift:set-type-reference-descriptor!
	 reference (thrift:make-parameterized-field-type-descriptor
		    name #f (thrift:field-type-descriptor-wire-type prototype)
		    #f #f #f (thrift:field-type-descriptor-default prototype)
		    parameters))))
   
    (define external-contexts
      (thriftc:type-resolution-context-registry-external-contexts registry))
    (define root (thriftc:type-resolution-context-registry-root registry))
    
    (cond
     ((thrift:complex-type-reference? reference)
      (resolve-complex-type-reference reference))

     ;; Check for cached descriptor only if it's not a complex type reference.

     ((thrift:type-reference-descriptor reference) =>
      (lambda (descriptor) descriptor))
     ((thrift:resolve-type (thrift:make-type-reference name #f) #f) =>
      (lambda (descriptor)
	(thrift:set-type-reference-descriptor! reference descriptor)
	descriptor))

     (else 
      (let* ((prefix (let ((dot (string-index-right name #\.)))
		       (and dot (substring name 0 dot))))
	     (suffix (if prefix (substring name (string-length prefix)) name))
	     (context (if prefix 
			  (hashtable-ref external-contexts prefix #f) 
			  root)))
	(or context 
	    (raise (condition
		    (make-assertion-violation)
		    (make-message-condition 
		     (string-append "Unknown type prefix " prefix))
		    (thriftc:make-type-resolution-condition))))
	
	(let ((definition 
		(hashtable-ref
		 (thriftc:type-resolution-context-declared-types context) 
		 suffix 
		 #f)))
	  (or definition
	      (raise (condition
		      (make-assertion-violation)
		      (make-message-condition
		       (string-append "Unknown type " name))
		      (thriftc:make-type-resolution-condition))))
	  
	  (let ((descriptor
		 (cond 
		  ((thriftc:enum-definition? definition)
		   (thriftc:enum-definition->type-descriptor 
		    definition
		    (thriftc:type-resolution-context-namespace context)))
		  ((thriftc:struct-definition? definition)
		   (thriftc:struct-definition->type-descriptor 
		    definition
		    (thriftc:type-resolution-context-namespace context)))
		  ((thriftc:typedef-definition? definition)
		   (resolve-type-reference
		    (thriftc:typedef-definition-source-type definition) 
		    registry))
		  (else (raise (make-assertion-violation))))))

	    (thrift:set-type-reference-descriptor! reference descriptor)
	    descriptor))))))

  (define (extract-namespace thrift)
    (let loop ((namespaces (thriftc:thrift-namespaces thrift))
	       (namespace #f))
      (if (null? namespaces)
	  (or namespace "thrift.default")
	  (let* ((ns (car namespaces))
		 (lang (thriftc:namespace-language ns)))
	    (case lang
	      ((rnrs) (loop (cdr namespaces) (thriftc:namespace-name ns)))
	      ((#f) (loop (cdr namespaces) 
			  (or namespace (thriftc:namespace-name ns))))
	      (else (loop (cdr namespaces) namespace)))))))	    

  (define (resolve thrift context-registry)
    (define root-context 
      (thriftc:type-resolution-context-registry-root context-registry))
    (define namespace (extract-namespace thrift))

    (define (register-declared-type name definition)
      (if (hashtable-contains?
	   (thriftc:type-resolution-context-declared-types root-context) name)
	  (raise (condition 
		  (make-assertion-violation)
		  (make-message-condition 
		   (string-append "Conflicting type declarations for " 
				  name))
		  (thriftc:make-type-resolution-condition))))
      (hashtable-set!
       (thriftc:type-resolution-context-declared-types root-context) 
       name definition))

    (define (register-unresolved-type-reference type-reference)
      (define (register-unresolved-type-reference-inner type-reference)
	(if (not (thrift:type-reference-descriptor type-reference))
	    (hashtable-update! 
	     (thriftc:type-resolution-context-unresolved-references 
	      root-context)
	     (thrift:type-reference-name type-reference)
	     (lambda (refs) (cons type-reference refs))
	     (list type-reference))))

      (if (thrift:complex-type-reference? type-reference)
	  (for-each register-unresolved-type-reference-inner
		    (thrift:complex-type-reference-parameters type-reference))
	  (register-unresolved-type-reference-inner type-reference)))

    (define (scan-definition definition)
      (define (scan-field-definition definition)
	(register-unresolved-type-reference
	 (thriftc:field-definition-type definition)))
      (define (scan-function-definition definition)
	(register-unresolved-type-reference
	 (thriftc:function-definition-return-type definition))
	(for-each register-unresolved-type-reference
		  (map thriftc:field-definition-type
		       (thriftc:function-definition-arguments definition)))
	(for-each register-unresolved-type-reference
		  (thriftc:function-definition-throws definition)))

      (cond ((thriftc:const-definition? definition)
	     (register-unresolved-type-reference 
	      (thriftc:const-definition-type definition)))
	    ((thriftc:typedef-definition? definition)
	     (register-declared-type
	      (thriftc:typedef-definition-destination-type definition) 
	      definition)
	     (register-unresolved-type-reference 
	      (thriftc:typedef-definition-source-type definition)))
	    ((thriftc:enum-definition? definition)
	     (register-declared-type 
	      (thriftc:enum-definition-name definition) definition))
	    ((thriftc:service-definition? definition)
	     (register-declared-type 
	      (thriftc:service-definition-name definition) definition)
	     (for-each scan-function-definition
		       (thriftc:service-definition-functions definition)))
	    ((thriftc:struct-definition? definition)
	     (register-declared-type
	      (thriftc:struct-definition-name definition) definition)
	     (for-each scan-field-definition
		       (thriftc:struct-definition-fields definition)))))

    (define (resolve-const-definition definition)
      (resolve-type-reference 
       (thriftc:const-definition-type definition) context-registry))

    (define (resolve-field-definition definition)
      (resolve-type-reference
       (thriftc:field-definition-type definition) context-registry))
      
    (define (resolve-typedef-definition definition)
      (resolve-type-reference
       (thriftc:typedef-definition-source-type definition) context-registry))
    
    (define (resolve-enum-definition definition) (if #f #f))

    (define (resolve-service-definition service-definition)
      (define (resolve-function-definition function-definition)
	(define (resolve-throw-declaration throw-type)
	  (resolve-type-reference throw-type context-registry)
	  (let ((descriptor (thrift:type-reference-descriptor throw-type)))
	    (or (and (thrift:struct-field-type-descriptor? descriptor)
		     (thrift:struct-field-type-descriptor-exception? 
		      descriptor))
		(raise (condition 
			(make-message-condition 
			 (string-append 
			  "Function " 
			  (thriftc:function-definition-name function-definition)
			  " throws non-exception type "
			  (thrift:field-type-descriptor-name descriptor)))
			(make-assertion-violation)
			(thriftc:make-type-resolution-condition))))))
	
	(resolve-type-reference 
	 (thriftc:function-definition-return-type function-definition) 
	 context-registry)
	
	(for-each resolve-field-definition 
		  (thriftc:function-definition-arguments function-definition))
	(for-each resolve-throw-declaration
		  (thriftc:function-definition-throws function-definition)))

      (for-each resolve-function-definition
		(thriftc:service-definition-functions service-definition)))

    (define (resolve-struct-definition definition)
      (define is-union (thriftc:struct-definition-union? definition))
      (for-each resolve-field-definition
		(thriftc:struct-definition-fields definition)))

    (define (resolve-definition definition)
      (cond ((thriftc:const-definition? definition)
	     (resolve-const-definition definition))
	    ((thriftc:enum-definition? definition)
	     (resolve-enum-definition definition))
 	    ((thriftc:service-definition? definition)
	     (resolve-service-definition definition))
	    ((thriftc:struct-definition? definition)
	     (resolve-struct-definition definition))
	    ((thriftc:typedef-definition? definition)
	     (resolve-typedef-definition definition))
	    (else (raise 
		   (condition 
		    (make-assertion-violation)
		    (make-message-condition "Unknown definition type")
		    (thriftc:make-type-resolution-condition))))))

    (map (lambda (include)
	   (let* ((thrift ((thriftc:make-parser
			    (thriftc:make-tokenizer 
			     (open-input-file include)))))
		  (ext-registry (thriftc:make-type-resolution-context-registry
				 (thriftc:make-type-resolution-context 
				  #f (extract-namespace thrift)))))
	     (resolve thrift ext-registry)
	     (thriftc:type-resolution-context-registry-root ext-registry)))
	 (thriftc:thrift-includes thrift))
    (for-each scan-definition (thriftc:thrift-definitions thrift))
    (for-each resolve-definition (thriftc:thrift-definitions thrift)))

  (define (thriftc:resolve thrift)
    (resolve thrift (thriftc:make-type-resolution-context-registry 
		     (thriftc:make-type-resolution-context 
		      #f (extract-namespace thrift)))))
)